home *** CD-ROM | disk | FTP | other *** search
/ The X-Philes (2nd Revision) / The X-Philes Number 1 (1995).iso / xphiles / hp48_1 / astronom < prev    next >
Internet Message Format  |  1995-03-31  |  24KB
  1. From comp.sys.handhelds Mon Apr 15 21:52:40 1991
  2. Path: seq!ecsgate!mcnc!gatech!ncar!elroy.jpl.nasa.gov!usc!wuarchive!uwm.edu!spool.mu.edu!cs.umn.edu!uc!norge.unet.umn.edu!fin
  3. From: fin@norge.unet.umn.edu (Craig A. Finseth)
  4. Newsgroups: comp.sys.handhelds
  5. Subject: 48SX/S: Astronomy routines and Alamanc
  6. Message-ID: <3896@uc.msc.umn.edu>
  7. Date: 15 Apr 91 16:28:05 GMT
  8. Sender: news@uc.msc.umn.edu
  9. Organization: Univ Netw Serv, Univ of Minn
  10. Lines: 1112
  11.  
  12. This is a repost of the routines first posted a year or so ago.  This
  13. repost fixes a typo.  It also fixes some problems with flag -51 and
  14. cleans up the interface a bit (smaller, too, by 600 bytes).
  15.  
  16. If you like this, be sure to grab the browser that will be posted
  17. next...
  18.  
  19. Craig A. Finseth            fin@unet.umn.edu [CAF13]
  20. University Networking Services        +1 612 624 3375 desk
  21. University of Minnesota            +1 612 625 0006 problems
  22. 130 Lind Hall, 207 Church St SE        +1 612 626 1002 FAX
  23. Minneapolis MN 55455-0134, U.S.A.
  24.  
  25. ======================================================================
  26.  
  27. Written by: Lauren Nelson, Craig Finseth
  28. When: 23 June 1990, revised 13 April 1991
  29. What: Astronomy routines
  30.  
  31.     NOTE:  This program requires the separately supplied BROWSER
  32.     routine.
  33.  
  34. ALMANAC    ALMANAC program.  See below
  35. G->JD    Converts a date in y.md format to a Julian day number.
  36. JD->G    Converts a Julian day number to a date in y.md format.
  37. JD    Returns the current time as a Julian day number.
  38. LSIDT    Continuously displays the local sidereal time.
  39. SETUP    Initialize or modify ASPAR.
  40.  
  41. ADATE    Format a HP-48 date into a string as per the HP-41.
  42. ASOK    Checks whether ASPAR is present and calls SETUP if not.
  43. ASPAR    AStronomy PARameters. See below.
  44. ATIME    Format a HP-48 time in h.ms format into a string as per HP-41.
  45. deltaDAYS  Returns the number of days between two dates in y.md format.
  46. ELEV    Returns the elevation entry from ASPAR.  Ensures that ASPAR is present.
  47.  
  48. GTDIF    Returns the Greenwich time difference entry from ASPAR. 
  49.     Ensures that ASPAR is present.
  50. ->h$    Format a HP-48 angle in h.ms format into a string.
  51. JD->LSIDT  Converts a Julian day number with fractions to the local sidereal time.
  52. JDOW    Converts a Julian day number to the string form of its day of the week.
  53. LAT    Returns the latitude entry from ASPAR in decimal degrees. Ensures
  54.     that ASPAR is present.
  55. LONG    Returns the longitude entry from ASPAR in decimal degrees. Ensures
  56.     that ASPAR is present.
  57.  
  58. OBJECTS    Directory of astronomical object information.  These items
  59.     must be set manually.  They are:
  60.  
  61.     SolarSystem    Contains names and special RA/decl flags for
  62.             selected solar system objects.
  63.     BrightStars    Contains names and RA/decl data for selected
  64.             bright stars.
  65.     Messier        Contains names and RA/decl data for selected
  66.             Messier objects.
  67.  
  68. P->R    Polar to Rectangular coordinate conversion.
  69. R->P    Rectangular to Polar coordinate conversion.
  70. YMD->    Converts a date in y.md format to HP-48SX format.
  71. ->YMD    Converts a date in HP-48SX format to y.md format.
  72. YMD$    Converts a date in y.md format to string form.
  73.  
  74.  
  75. General notes:
  76.  
  77. Julian day numbers: Many of these routines use Julian day numbers. 
  78. These routines assume that the Julian to Gregorian calendar switch was
  79. made in October 1582.  They also assume that there is no year 0.
  80.  
  81. YY.MMDD Format: Many of these routines use this format for dates.  This
  82. format allows for direct representation of negative years.  They also allow
  83. for representing time as a fractional day of the month.
  84.  
  85. ------------------------------------------------------------
  86. ASPAR:  AStronomy PARameters
  87.  
  88. This data object is contains the basic astronomical observation
  89. parameters.  It is a list with four entries:
  90.  
  91.     Greenwich Mean Time Difference: The difference between your
  92.     local time and GMT in h.ms form.  Positive for time zones west
  93.     of Greenwich.
  94.  
  95.     Longitude: Your longitude in d.ms format.
  96.  
  97.     Latitude: Your latitude in d.ms format.
  98.  
  99.     Elevation: Your height above mean sea level (MSL) in meters.
  100.  
  101. These values can be accessed directly, or through interface procedures
  102. (GTDIF, LONG, LAT, ELEV).  All uses of ASPAR should be prefaced with a
  103. call to ASOK to ensure that ASPAR exists.  If you use these interface
  104. procedures, this call is handled for you.
  105.  
  106. ------------------------------------------------------------
  107. Detailed Interfaces:
  108.  
  109. ALMANAC    Directory.
  110.  
  111. G->JD    Stack Input:    date in YY.MMDD format
  112.     Stack Output:    corresponding Julian day number
  113.     Calls:        JD->G
  114.  
  115. JD->G    Stack Input:    Julian day number
  116.     Stack Output:    corresponding date in YY.MMDD format
  117.  
  118. JD    Stack Input:    none
  119.     Stack Output:    current time as a Julian day number fraction to
  120.             4 decimal places
  121.     Calls:        G->JD, GTDIF, ->YMD
  122.  
  123. LSIDT    Stack Input:    none
  124.     Stack Output:    none
  125.     Calls:        ATIME, GTDIF, LONG
  126.  
  127.     Continual display of the local time and the local sidereal time. 
  128.     Exits when any key is pressed.
  129.  
  130. SETUP    Stack Input:    none
  131.     Stack Output:    none
  132.     Global Input:    ASPAR
  133.     Global Output:    ASPAR
  134.     Calls:        BROWSE
  135.  
  136. ADATE    Stack Input:    date in HP-48 format
  137.     Stack Output:    date formatted into a string as per HP-41
  138.  
  139. ASOK    Stack Input:    none
  140.     Stack Output:    none
  141.     Global Input:    ASPAR
  142.     Calls:        SETUP
  143.  
  144.     Checks whether ASPAR is present and performs some minimal
  145. verfification of its integrity.   If ASPAR is not present or not
  146. intact, it calls SETUP.
  147.  
  148. ASPAR    AStronomy PARameters.  See above.
  149.  
  150. ATIME    Stack Input:    time in HH.MMSS format
  151.     Stack Output:    time formatted into a string as per HP-41
  152.  
  153. deltaDAYS  Stack Input:    date1 in YY.MMDD format
  154.             date2 in YY.MMDD format
  155.     Stack Output:    number of days between the dates
  156.     Calls:        G->JD
  157.  
  158. ELEV    Stack Input:    none
  159.     Stack Output:    height value from ASPAR
  160.     Global Input:    ASPAR
  161.     Calls:        ASOK
  162.  
  163. GTDIF    Stack Input:    none
  164.     Stack Output:    Greenwich mean time difference value from
  165.             ASPAR in decimal hours
  166.     Global Input:    ASPAR
  167.     Calls:        ASOK
  168.  
  169. ->h$    Stack Input:    angle in h.ms format
  170.     Stack Output:    angle formatted into a string
  171.  
  172. JD->LSIDT  Stack Input:    Julian day number and fraction
  173.     Stack Output:    local sidereal time for that instant
  174.     Calls:        GTDIF, JD->G, LONG, YMD->
  175.  
  176. JDOW    Stack Input:    Julian day number
  177.     Stack Output:    day of week for that date in string format
  178.  
  179. LAT    Stack Input:    none
  180.     Stack Output:    latitude value from ASPAR in decimal degrees
  181.     Global Input:    ASPAR
  182.     Calls:        ASOK
  183.  
  184. LONG    Stack Input:    none
  185.     Stack Output:    longitude value from ASPAR in decimal degrees
  186.     Global Input:    ASPAR
  187.     Calls:        ASOK
  188.  
  189. OBJECTS    Directory.
  190.  
  191. P->R    Stack Input:    radius
  192.             angle
  193.     Stack Output:    x coordinate w/tag
  194.             y coordinate w/tag
  195.  
  196.     Polar to rectangular coordinate conversions.  You would have
  197.     thought that HP would include this.
  198.  
  199. R->P    Stack Input:    x coordinate
  200.             y coordinate
  201.     Stack Output:    radius w/tag
  202.             angle w/tag
  203.  
  204.     Rectangular to polar coordinate conversions.  You would have
  205.     thought that HP would include this.
  206.  
  207. YMD->    Stack Input:    date in YY.MMDD format
  208.     Stack Output:    corresponding date in the current format
  209.     Calls:        ->YMD
  210.  
  211. ->YMD    Stack Input:    date in the current HP-48 format
  212.     Stack Output:    corresponding date in YY.MMDD format
  213.  
  214. YMD$    Stack Input:    date in YY.MMDD
  215.     Stack Output:    date formatted into a string
  216.     Calls:        ATIME
  217.  
  218. ============================================================
  219. ALMANAC Directory
  220.  
  221. NOW    Set the date/time to the now.
  222. THING    Select an object and display its alt/az.
  223. SUN    Display the Sun's alt/az.
  224. MOON    Display the Moon's alt/az.
  225. RISE    Calculate the rise and set times for the object whose
  226.     alt/az was last calculated.
  227. WHEN    Prompts for the observation date and time.
  228.  
  229. ASOBJECT  Variable: Current object.  Set by THING.
  230. C->AA    Transform RA/decl coordinates to alt/az.
  231. DECL    Variable: Declination.  Set by FIG.
  232. E->C    Transform ecliptical coordinatess to RA/decl coordinates.
  233. FIGC    Figure alt/az for the specified object.
  234. FIGT    Figure the Century Time.
  235.  
  236. MNalphadelta  Figure the RA and decl for the Moon.
  237. OTJD    Variable: The Julian date/time that the observation is for.
  238.     Set with STOT
  239. RA    Variable: Right ascension.  Set by FIG.
  240. SETOT    Set the observation time.
  241. SNalphadelta  Figure the RA and decl for the Sun.
  242.  
  243.  
  244. Note: The formulae used in this program have been approximated for
  245. late 20th century use.  More exact formulae may be created by
  246. consulting the references.  These objects are affected by these
  247. approximations:
  248.  
  249.     E->C
  250.     FIGT
  251.     MNalphadelta
  252.     SNalphadelta
  253.     OBJECTS:BrightStars
  254.     OBJECTS:Messier    
  255.  
  256.  
  257. Basic operation:
  258.  
  259. 1) Run SETUP to initialize ASPAR.
  260.  
  261. 2) Press NOW or enter a date using WHEN.
  262.  
  263. 3) Press THING and select an object, or press SUN or MOON.
  264.  
  265. 4) If desired, press RISE to see the rise and set times.
  266.  
  267. You may add additional objects by adding to the existing objects in
  268. the OBJECTS directory, or by creating new object lists (they will
  269. automatically be picked up by THING).  If you wish to add objects
  270. whose RA/decl vary, you need to define and use special flag RAs (93,
  271. 94, ...), add them to FIG, and create procedures to calculate the
  272. RA/decl.
  273.  
  274. In future versions, we will replace the RA and decl constants and flag
  275. information with a procedure that returns these values.
  276.  
  277. ------------------------------------------------------------
  278. Data Types:
  279.  
  280. what            name used    range            type
  281.             in program
  282.  
  283. object            N        selected list        string
  284.  
  285. observer latitude            -90 (S) to +90 (N)    D.MS
  286. observer longitude            -180 (E) to +180 (W)    D.MS
  287.  
  288. right ascension        RA, alpha    0 to 23.5959        H.MS
  289. declination        DECL, delta    0 to 359.5959        D.MS
  290.  
  291. altitude                -90 (nadir) to +90 (zenith)    D.MS
  292. azimuth                    0 (N) to +359.59.59     D.MS
  293.                      (E=90, S=180, W=270)
  294. ecliptical (celestial)
  295.     longitude    lambda        0 to +359.59.59         decimal degrees
  296. ecliptical (celestial)
  297.     latitude    beta        -90 to +90        decimal degrees
  298.  
  299.  
  300.  
  301. Object List:
  302.  
  303. The object lists in the OBJECTS directory are lists of lists.  Each
  304. sublist has an object name, its right ascention, and its declination
  305. as:
  306.  
  307.     { { N1 RA1 decl1 } { N2 RA2 decl2 } ... }
  308.  
  309. An object with a declination of +91 is assumed to be the Sun.  An
  310. object with a declination of +92 is assumed to be the Moon.
  311.  
  312.  
  313. ------------------------------------------------------------
  314. Detailed Interfaces:
  315.  
  316. NOW    Stack Input:    none
  317.     Stack Output:    none
  318.     Calls:        SETOT, ->YMD
  319.  
  320. THING    Stack Input:    none
  321.     Stack Output:    object
  322.             object's altitude
  323.             object's azimuth
  324.     Global Input:    OBJECTS directory
  325.     Global Output:    ASOBJECT
  326.     Calls:        BROWSE (separately supplied), FIGC
  327.  
  328. SUN    Stack Input:    none
  329.     Stack Output:    none
  330.     Screen:        "Sun"
  331.             Sun's altitude
  332.             Sun's azimuth
  333.     Global Output:    ASOBJECT
  334.     Calls:        FIGC
  335.  
  336. MOON    Stack Input:    none
  337.     Stack Output:    none
  338.     Screen:        "Moon"
  339.             Moon's altitude
  340.             Moon's azimuth
  341.     Global Output:    ASOBJECT
  342.     Calls:        FIGC
  343.  
  344. RISE    Stack Input:    none
  345.     Stack Output:    none
  346.     Screen:        oject name
  347.             object's rising time
  348.             object's rising azimuth
  349.             object's setting time
  350.             object's setting azimuth
  351.     Global Input:    ASOBJECT, DECL, OTJD, RA
  352.     Global Output:    OTJD
  353.     Calls:        ATIME, G->JD, GTDIF, JD->G, LAT, LONG, YMD->,
  354.             ->YMD
  355.  
  356.     Figure an object's rise and set times.  It uses the last
  357. object whose altitude and azimuth were computed (i.e., the last
  358. invocation of THING, SUN, or MOON).
  359.  
  360. WHEN    Stack Input:    none
  361.     Stack Output:    none
  362.     Calls:        SETOT
  363.  
  364.     Prompts for observation date and time.
  365.  
  366. ASOBJECT  Variable.
  367.  
  368. C->AA    Stack Input:    RA
  369.             decl
  370.     Stack Output:    az w/tag
  371.             alt w/tag
  372.     Global Input:    OTJD
  373.     Calls:        JD->LSIDT, LAT
  374.  
  375.     Applies correction for atmospheric refraction for altitudes
  376. starting at -.55 degrees.
  377.  
  378. DECL    Variable.
  379.  
  380. E->C    Stack Input:    ecliptical longitude
  381.             ecliptical latitude
  382.     Stack Output:    RA
  383.             decl
  384.     Calls:        R->P
  385.  
  386. FIGC    Stack Input:    list containing object, RA, decl
  387.     Stack Output:    object
  388.             azimuth w/tag
  389.             altitude w/tag
  390.     Global Input:    ASOBJECT
  391.     Global Output:    DECL, RA
  392.     Calls:        C->AA, MNalphadelta, SNalphadelta
  393.  
  394.     Figure the altitude and azimuth for the specified object.
  395.     Also record the object's right ascension and declination.
  396.  
  397. FIGT    Stack Input:    none
  398.     Stack Output:    Century Time
  399.     Global Input:    OTJD
  400.  
  401. MNalphadelta  Stack Input:    none
  402.     Stack Output:    Moon's RA
  403.             Moon's declination
  404.     Calls:        E->C, FIGT
  405.  
  406. OTJD    Variable.
  407.  
  408. RA    Variable.
  409.  
  410. SETOT    Stack Input:    date in YY.MMDD format
  411.     Stack Output:    none
  412.     Global Output:    OTJD
  413.     Calls:        G->JD, GTDIF
  414.  
  415. SUNalphadelta    Stack Input:    none
  416.     Stack Output:    Sun's RA
  417.             Sun's declination
  418.     Calls:        FIGT, R->P
  419.  
  420. ------------------------------------------------------------
  421. ~References:
  422.  
  423. Hirshfeld, Alan and Sinnott, Roger W., "Sky Catalogue 2000.0," 2
  424. volumes, Cambridge University Press, Cambridge, UK, 1982.
  425.  
  426. Meeus, Jean, "Astronomical Formulae for Calculators, Second Edition,"
  427. Willmann-Bell, Inc., Richmond, VA, 1982.
  428.  
  429. "The Concise Planetary Ephemeris for 1950 to 2000 A.D.," The Hieratic
  430. Publishing Co., Medford, MA, 1977.
  431.  
  432.  
  433. Checksum: #a5h
  434. Size: 9243.5
  435. ------------------------------------------------------------
  436. %%HP: T(3)A(D)F(.);
  437. DIR
  438.   ALMANAC
  439.     DIR
  440.       NOW
  441.         \<< TIME DATE
  442. WHEN
  443.         \>>
  444.       THING
  445.         \<< PATH
  446. OBJECTS {
  447. "    Select a Class"
  448. 1 0
  449.           \<<
  450.           \>> } VARS
  451. BROWSE SWAP DROP
  452. OBJ\-> DROP SWAP DROP
  453.           IF 0 ==
  454.           THEN
  455. UPDIR DROP
  456.           ELSE {
  457. "  Select an Object"
  458. 1 0
  459.             \<< 1 GET
  460.             \>> }
  461. SWAP BROWSE SWAP
  462. DROP OBJ\-> DROP SWAP
  463. DROP
  464.             IF 0 ==
  465.             THEN
  466. UPDIR DROP
  467.             ELSE
  468. UPDIR SWAP EVAL
  469. 'ASOBJECT' STO FIGC
  470.             END
  471.           END
  472.         \>>
  473.       SUN
  474.         \<< { "Sun"
  475. 91 0 } 'ASOBJECT'
  476. STO FIGC 4 RND
  477. "Alt: " SWAP + SWAP
  478. 4 RND "Az: " SWAP +
  479.         \>>
  480.       MOON
  481.         \<< { "Moon"
  482. 92 0 } 'ASOBJECT'
  483. STO FIGC 4 RND
  484. "Alt: " SWAP + SWAP
  485. 4 RND "Az: " SWAP +
  486.         \>>
  487.       RISE
  488.         \<< OTJD DUP
  489. GTDIF 24 / - \-> P O
  490.           \<< RCLF
  491. DEG 0 3
  492.             FOR I
  493. -.009
  494.               IF
  495. ASOBJECT 1 GET DUP
  496. "Sun" SAME SWAP
  497. "Moon" SAME OR
  498.               THEN
  499. .0045 -
  500.               END
  501. LAT SIN DECL HMS\->
  502. SIN * - LAT COS
  503. DECL HMS\-> COS * /
  504. ACOS 15 / RA HMS\->
  505. SWAP DUP2 - 3 ROLLD
  506. + 1.002738 6.66452
  507. LONG 15 / - SWAP
  508. GTDIF * + O JD\->G
  509. YMD\-> 1.012 DDAYS
  510. 15.218442 / - DUP
  511. ROT SWAP - 24 MOD
  512. 1.002738 / 3 ROLLD
  513. - 24 MOD 1.002738 /
  514. O JD\->G YMD\-> \->YMD
  515.               IF I
  516. 2 <
  517.               THEN
  518. ROT DROP SWAP
  519.               ELSE
  520. SWAP DROP SWAP
  521.               END
  522.               IF I
  523. 2 MOD 1 ==
  524.               THEN
  525. DUP \->HMS 4 RND
  526. ATIME
  527. IF I 1 ==
  528. THEN "RISE"
  529. ELSE "SET"
  530. END \->TAG I 1 + DISP
  531.               END
  532. 240000 / + G\->JD
  533. GTDIF 24 / + 'OTJD'
  534. STO FIGC ROT
  535.               IF I
  536. 0 ==
  537.               THEN
  538. CLLCD 1 DISP
  539.               ELSE
  540. DROP
  541.               END
  542. DROP
  543.               IF I
  544. 2 MOD 1 ==
  545.               THEN
  546. 2 RND "Az" \->TAG I 2
  547. + DISP
  548.               ELSE
  549. DROP
  550.               END
  551.             NEXT 7
  552. FREEZE STOF P
  553. 'OTJD' STO
  554.           \>>
  555.         \>>
  556.       WHEN
  557.         \<< \->YMD
  558. SETOT
  559.         \>>
  560.       ASOBJECT {
  561. "Sun" 91 0 }
  562.       C\->AA
  563.         \<< HMS\-> SWAP
  564. HMS\-> 15 * SWAP \-> \Ga
  565. \Gd
  566.           \<< OTJD
  567. JD\->LSIDT HMS\-> 15 *
  568. \Ga - \-> H
  569.             \<< RCLF
  570. DEG H SIN H COS LAT
  571. SIN * \Gd TAN LAT COS
  572. * - SWAP R\->C ARG
  573. 180 + 360 MOD LAT
  574. SIN \Gd SIN * LAT COS
  575. \Gd COS * H COS * +
  576. ASIN DUP
  577.               IF
  578. -.55 >
  579.               THEN
  580. DUP 3.4 + 1.6 SWAP
  581. / .017130621 - +
  582.               END
  583. \->HMS "Alt" \->TAG
  584. SWAP \->HMS "Az" \->TAG
  585. SWAP ROT STOF
  586.             \>>
  587.           \>>
  588.         \>>
  589.       DECL
  590. 9.09308006447
  591.       E\->C
  592.         \<<
  593. 23.4392911 \-> \Gl \Gb \Ge
  594.           \<< RCLF
  595. DEG \Gl SIN \Ge COS * \Gb
  596. TAN \Ge SIN * - \Gl COS
  597. SWAP R\->P SWAP DROP
  598. 15 / \->HMS \Gb SIN \Ge
  599. COS * \Gb COS \Ge SIN *
  600. \Gl SIN * + ASIN \->HMS
  601. ROT STOF
  602.           \>>
  603.         \>>
  604.       FIGC
  605.         \<< ASOBJECT
  606. OBJ\-> DROP DUP2 DROP
  607.           IF 91 ==
  608.           THEN
  609. DROP2 SN\Ga\Gd
  610.           END
  611.           IF DUP2
  612. DROP 92 ==
  613.           THEN
  614. DROP2 MN\Ga\Gd
  615.           END DUP2
  616. 'DECL' STO 'RA' STO
  617. C\->AA
  618.         \>>
  619.       FIGT
  620.         \<< OTJD
  621. 2415020 - 36525 /
  622.         \>>
  623.       MN\Ga\Gd
  624.         \<< FIGT \-> T
  625.           \<<
  626. 270.434164
  627. 481267.8831 T * +
  628. 360 MOD 358.475833
  629. 35999.0498 T * +
  630. 296.104608
  631. 477198.8491 T * +
  632. 350.737486
  633. 445267.1142 T * +
  634. 11.250889
  635. 483202.0251 T * + \->
  636. LP M MP D F
  637.             \<< RCLF
  638. DEG LP 6.28875 MP
  639. SIN * + 1.274018 D
  640. 2 * MP - SIN * +
  641. .658309 D 2 * SIN *
  642. + 5.128189 F SIN *
  643. .280606 MP F + SIN
  644. * + .277693 MP F -
  645. SIN * + E\->C ROT
  646. STOF
  647.             \>>
  648.           \>>
  649.         \>>
  650.       OTJD
  651. 2448360.23786
  652.       RA
  653. 1.27187705312
  654.       SETOT
  655.         \<< G\->JD SWAP
  656. HMS\-> GTDIF + 24 / +
  657. 'OTJD' STO
  658.         \>>
  659.       SN\Ga\Gd
  660.         \<< RCLF DEG
  661. FIGT \-> T
  662.           \<<
  663. 279.69668
  664. 36000.76892 T * +
  665. .0003025 T SQ * +
  666. 358.47583
  667. 35999.04975 T * +
  668. .00015 T SQ * -
  669. .0000033 T 3 ^ * -
  670. \-> L M
  671.             \<<
  672. 1.91946 .004789 T *
  673. - .000014 T SQ * -
  674. M SIN * .020094
  675. .0001 T * - M 2 *
  676. SIN * + .000293 M 3
  677. * SIN * + 23.452294
  678. .0130125 T * -
  679. .00000164 T SQ * -
  680. .000000503 T 3 ^ *
  681. + 259.18 1934.142 T
  682. * - DUP COS .00256
  683. * ROT + \-> C \GW \Ge
  684.               \<< L C
  685. + .00569 .00479 \GW
  686. SIN * - - \-> SLA
  687. \<< \Ge COS SLA SIN *
  688. SLA COS SWAP R\->P
  689. SWAP DROP 15 / \->HMS
  690. \Ge SIN SLA SIN *
  691. ASIN \->HMS
  692. \>>
  693.               \>>
  694.             \>>
  695.           \>> ROT
  696. STOF
  697.         \>>
  698.     END
  699.   G\->JD
  700.     \<< DUP DUP IP
  701. SWAP ABS FP 100 *
  702. DUP IP SWAP FP 100
  703. * 4 ROLL 0 0 0 0 \->
  704. Y M D J M1 Y1 C B
  705.       \<<
  706.         IF M 2 \<=
  707.         THEN Y 1 -
  708. 'Y1' STO M 12 +
  709. 'M1' STO
  710.         ELSE Y 'Y1'
  711. STO M 'M1' STO
  712.         END
  713.         IF J
  714. 1582.1015 \>=
  715.         THEN 2 Y1
  716. 100 / IP - Y1 400 /
  717. IP + 'B' STO
  718.         END
  719.         IF Y 0 \<=
  720.         THEN .75
  721. 'C' STO 1 'Y1' STO+
  722.         END 365.25
  723. Y1 * C - IP 30.6001
  724. M1 1 + * IP + D +
  725. 1720994.5 + B + DUP
  726. J SWAP JD\->G
  727.         IF \=/
  728.         THEN DROP J
  729. # D01h DOERR
  730.         END
  731.       \>>
  732.     \>>
  733.   JD\->G
  734.     \<< DUP
  735.       IF 0 <
  736.       THEN
  737. "Negative Julian Day"
  738. DOERR
  739.       END .5 + DUP
  740. IP DUP ROT FP SWAP
  741. 1867216.25 -
  742. 36524.25 / IP 3
  743. PICK
  744.       IF 2299161 <
  745.       THEN DROP
  746. SWAP
  747.       ELSE DUP 4 /
  748. IP - 1 + ROT +
  749.       END 1524 +
  750. DUP 122.1 - 365.25
  751. / IP DUP 365.25 *
  752. IP DUP 4 PICK SWAP
  753. - 30.6001 / IP SWAP
  754. 4 ROLL SWAP - SWAP
  755. DUP 30.6001 * IP
  756. ROT SWAP - 4 ROLL +
  757. SWAP DUP
  758.       IF 13.5 <
  759.       THEN 1 -
  760.       ELSE 13 -
  761.       END DUP
  762.       IF 2.5 >
  763.       THEN ROT 4716
  764. -
  765.       ELSE ROT 4715
  766. -
  767.       END DUP
  768.       IF 0 \<=
  769.       THEN 1 -
  770.       END SWAP ROT
  771. 100 / + 100 / SWAP
  772. DUP SIGN SWAP ABS
  773. ROT + *
  774.     \>>
  775.   JD
  776.     \<< GTDIF TIME
  777. HMS+ 4 RND HMS\-> 24
  778. / DUP FP 10000 /
  779. SWAP IP DATE SWAP
  780. DATE+ \->YMD SWAP +
  781. G\->JD
  782.     \>>
  783.   LSIDT
  784.     \<< 6.66452 LONG
  785. 15 / - GTDIF
  786. 1.002738 * + .0002
  787. + RCLF 3 FIX CLLCD
  788. "Local Siderial Time."
  789. 5 DISP
  790. "Local Time." 1
  791. DISP SWAP \-> a
  792.       \<<
  793.         DO a DATE
  794. 1.012 DDAYS
  795. 15.21842 / - \-> Y
  796.           \<<
  797.             WHILE
  798.               IF 0
  799. KEY ==
  800.               THEN
  801. TIME .00005 HMS+
  802. DUP HMS\-> DUP 4 TRNC
  803.               ELSE
  804. 0 0
  805.               END 0
  806. \=/
  807.             REPEAT
  808. SWAP 4 TRNC ATIME 2
  809. DISP 1.002738 * Y +
  810. 24 MOD \->HMS 4 TRNC
  811. RCLF SWAP -41 SF
  812. ATIME 6 DISP STOF
  813.             END
  814.           \>>
  815.         UNTIL 0 ==
  816.         END
  817.       \>> DROP STOF
  818.     \>>
  819.   SETUP
  820.     \<< { :GMT: 0
  821. :EST: 5 :EDT: 4
  822. :CST: 6 :CDT: 5
  823. :MST: 7 :MDT: 6
  824. :PST: 8 :PDT: 7
  825. :AST: 9 :ADT: 8 } \->
  826. TZ
  827.       \<< { } ASPAR
  828. DUP TYPE
  829.         IF 5 \=/ SWAP
  830. SIZE 4 \=/ OR
  831.         THEN :GMT:
  832. 0
  833.         ELSE ASPAR
  834. 1 GET
  835.         END {
  836. "SELECT A TIME ZONE"
  837. } TZ ROT POS + 0 +
  838.         \<<
  839.         \>> + TZ
  840. BROWSE 1 GET SWAP
  841. DROP
  842.       \>> +
  843. "ENTER Your longitude"
  844. 10 CHR +
  845. "as deg . min sec"
  846. + { } ":Long.:"
  847.       IFERR ASPAR 2
  848. GET DTAG
  849.       THEN ""
  850.       END + + -8 +
  851. V + INPUT OBJ\-> +
  852. "ENTER Your latitude."
  853. 10 CHR +
  854. "as deg . min sec"
  855. + { } ":Lat.:"
  856.       IFERR ASPAR 3
  857. GET DTAG
  858.       THEN ""
  859.       END + + -7 +
  860. V + INPUT OBJ\-> +
  861. "ENTER Your altitude"
  862. 10 CHR +
  863. "in meters." + { }
  864. ":ELEV.:"
  865.       IFERR ASPAR 4
  866. GET DTAG OBJ\-> DROP
  867.       THEN ""
  868.       END + + -7 +
  869. V + INPUT OBJ\-> '1_m
  870. ' \->UNIT "ELEV."
  871. \->TAG + 'ASPAR' STO
  872.     \>>
  873.   ADATE
  874.     \<< DUP 1 TSTR 1
  875. 10 SUB SWAP 100 *
  876. FP 10000 * +
  877.     \>>
  878.   ASOK
  879.     \<< ASPAR DUP
  880. TYPE
  881.       IF 5 \=/ SWAP
  882. SIZE 4 \=/ OR
  883.       THEN SETUP
  884.       END
  885.     \>>
  886.   ASPAR { :CDT: 5
  887. :Long.: 93.104213
  888. :Lat.: 44.57546
  889. :ELEV.: '278.9_m' }
  890.   ATIME
  891.     \<< HMS\-> \->HMS
  892.       IF -41 FC?
  893.       THEN 24 MOD
  894.       END DUP SIGN
  895. SWAP ABS DUP IP
  896. SWAP DUP DUP 4 TRNC
  897. - 10000 * SWAP FP
  898. 1.1 SWAP
  899.       IF -41 FC?
  900.       THEN 4 PICK +
  901.       END TSTR -41
  902.       IF FS?
  903.       THEN 17 22
  904. SUB SWAP DUP
  905.         IF 0 ==
  906.         THEN DROP
  907.         ELSE \->STR
  908.           IF DUP
  909. "E" POS 0 ==
  910.           THEN DUP
  911. DUP "." POS SWAP
  912. SIZE SUB +
  913.           ELSE DROP
  914.           END
  915.         END
  916.       ELSE DUP 14
  917. 21 SUB " " + SWAP
  918. 22 22 SUB + "M" +
  919. SWAP DROP
  920.       END SWAP
  921.       IF -41 FS?
  922.       THEN \->STR DUP
  923. 1 SWAP "." POS 1 -
  924. DUP
  925.         IF 1 <
  926.         THEN DROP
  927. OVER SIZE
  928.         END SUB
  929. SWAP +
  930.       ELSE DROP
  931.       END SWAP
  932.       IF 0 <
  933.       THEN "-" SWAP
  934. +
  935.       END
  936.     \>>
  937.   \GdDAYS
  938.     \<< G\->JD SWAP
  939. G\->JD -
  940.     \>>
  941.   ELEV
  942.     \<< ASOK ASPAR 4
  943. GET
  944.     \>>
  945.   GTDIF
  946.     \<< ASOK ASPAR 1
  947. GET HMS\->
  948.     \>>
  949.   \->h$
  950.     \<< RCLF STD SWAP
  951. HMS\-> \->HMS DUP FP
  952. \->STR SIZE DUP 4
  953.       IF \<=
  954.       THEN DROP 4
  955. FIX
  956.       ELSE 1 - FIX
  957.       END \->STR DUP
  958. "." POS SWAP OVER
  959. "h" REPL DUP 3 PICK
  960. 2 + OVER SIZE SUB 1
  961. "m" REPL ROT 3 +
  962. DUP 4 ROLLD SWAP
  963. REPL "s" + SWAP 2 +
  964. OVER OVER OVER SIZE
  965. DUP2
  966.       IF \>=
  967.       THEN 4 DROPN
  968.       ELSE SUB 1
  969. "." REPL SWAP 1 +
  970. SWAP REPL
  971.       END SWAP STOF
  972.     \>>
  973.   JD\->LSIDT
  974.     \<< GTDIF 24 / -
  975. \-> J
  976.       \<< 1.002738
  977. 6.66452 LONG 15 / -
  978. OVER GTDIF * + J
  979. JD\->G YMD\-> 1.012
  980. DDAYS 15.218442 / -
  981. SWAP J JD\->G 10000 *
  982. FP 24 * * + 24 MOD
  983. \->HMS
  984.       \>>
  985.     \>>
  986.   JDOW
  987.     \<< 0 RND 1 + 7
  988. MOD
  989. "SUNMONTUEWEDTHUFRISAT"
  990. SWAP DUP 3 * 1 +
  991. SWAP 1 + 3 * SUB
  992.     \>>
  993.   LAT
  994.     \<< ASOK ASPAR 3
  995. GET HMS\->
  996.     \>>
  997.   LONG
  998.     \<< ASOK ASPAR 2
  999. GET HMS\->
  1000.     \>>
  1001.   OBJECTS
  1002.     DIR
  1003.       SolarSystem {
  1004. { "Sun" 91 0 } {
  1005. "Moon" 92 0 } }
  1006.       BrightStars {
  1007. { "\Ga Tau:Aldebaran"
  1008. 4.3555 16.3033 } {
  1009. "\Gb Per:Algol" 3.081
  1010. 40.5721 } {
  1011. "\Ga Aql:Altair"
  1012. 19.5046 8.5206 } {
  1013. "\Ga Sco:Antares"
  1014. 16.2924 -26.2555 }
  1015. { "\Ga Boo:Arcturus"
  1016. 14.1539 19.1057 } {
  1017. "\Gg Ori:Bellatrix"
  1018. 5.2507 6.2059 } {
  1019. "\Ga Ori:Betelguese"
  1020. 5.551 7.2426 } {
  1021. "\Ga Car:Canopus"
  1022. 6.2357 -45.5651 } {
  1023. "\Ga Aur:Capella"
  1024. 5.1641 45.5953 } {
  1025. "\Ga Cyg:Deneb"
  1026. 20.4125 45.1649 } {
  1027. "\Gb Tau:Elnath"
  1028. 5.2617 28.3627 } {
  1029. "\Ga PsA:Fomalhaut"
  1030. 22.5738 -29.372 } {
  1031. "\Gs Cet:Mira" 2.1921
  1032. 60.291 } {
  1033. "\Ga UMi:Polaris"
  1034. 2.315 89.1551 } {
  1035. "\Gb Gem:Pollux"
  1036. 7.4518 28.0134 } {
  1037. "\Ga CMi:Procyon"
  1038. 7.3918 5.133 } {
  1039. "\Ga Leo:Regulus"
  1040. 10.0822 11.5802 } {
  1041. "\Gb Ori:Rigel"
  1042. 5.1432 -8.1206 } {
  1043. "\Ga Sgr:Rukbat"
  1044. 19.2353 -40.3658 }
  1045. { "\Ga CMa:Sirius"
  1046. 6.4508 -16.4258 } {
  1047. "\Ga Vir:Spica"
  1048. 13.2511 -11.0941 }
  1049. { "\Ga Lyr:Vega"
  1050. 18.3656 38.4701 } {
  1051. "\Ga Cen" 14.3935
  1052. -60.5013 } {
  1053. "\Gt Cet" 1.4404
  1054. -15.5615 } }
  1055.       Messier { {
  1056. "M1:Crab Nebula"
  1057. 5.34 22.01 } {
  1058. "M31:Andromeda" .43
  1059. 41.16 } {
  1060. "M42:Orion Nebula"
  1061. 5.35 -5.27 } {
  1062. "M45:Pleiades" 3.47
  1063. 24.07 } }
  1064.     END
  1065.   P\->R
  1066.     \<< DUP2 COS *
  1067. "x" \->TAG 3 ROLLD
  1068. SIN * "y" \->TAG
  1069.     \>>
  1070.   R\->P
  1071.     \<< R\->C DUP ABS
  1072. "r" \->TAG SWAP ARG
  1073. "\<)" \->TAG
  1074.     \>>
  1075.   YMD\->
  1076.     \<< 4 TRNC
  1077.       IF -42 FC?
  1078.       THEN \->YMD
  1079. \->YMD 100 /
  1080.       ELSE DUP IP
  1081. SWAP FP 100 * DUP
  1082. IP SWAP FP 100 *
  1083. SWAP ROT 10000 / +
  1084. 100 / +
  1085.       END
  1086.     \>>
  1087.   \->YMD
  1088.     \<< DUP IP SWAP
  1089. FP 100 * DUP IP
  1090. SWAP FP 10000 *
  1091.       IF -42 FC?
  1092.       THEN ROT ROT
  1093.       ELSE SWAP ROT
  1094.       END 100 / +
  1095. 100 / +
  1096.     \>>
  1097.   YMD$
  1098.     \<< DUP SIGN SWAP
  1099. ABS DUP IP SWAP DUP
  1100. DUP 4 TRNC - 10000
  1101. * SWAP FP 1.1 SWAP
  1102. TSTR -41
  1103.       IF FS?
  1104.       THEN 17 22
  1105.       ELSE 16 21
  1106.       END SUB SWAP
  1107. RCLF SWAP STD DUP
  1108.       IF 0 ==
  1109.       THEN DROP
  1110.       ELSE ROT "  "
  1111. + SWAP 24 * \->HMS 4
  1112. RND ATIME + SWAP
  1113.       END STOF +
  1114. SWAP
  1115.       IF 0 <
  1116.       THEN "-" SWAP
  1117. +
  1118.       END 1 2
  1119.       START DUP ":"
  1120. POS "/" REPL
  1121.       NEXT
  1122.     \>>
  1123. END
  1124.  
  1125.